Bürger*innenvorhersage Kandidaten Bundestagswahl 2021 als Tile Grid, Dot und Hexbin Maps

Cédric Scherer https://cedricscherer.com , Ansgar Wolsing
2021-09-27

Setup

pacman::p_load("tidyverse", "here", "glue", "colorspace", "gsheet", "labelled", "sf", "pdftools")

Daten

Tile Grid Map

grid <- read_csv(here("data", "de_constituencies_grid.csv"))

Vorhersage der Direktmandatsgewinner*innen 2021

Source: Kayser, Leininger, Murr & Stötzer (2021) Citizens’ Forecast for the 2021 German National Election https://aleininger.eu/citizens_forecast2021/

sheet_url <- "https://docs.google.com/spreadsheets/d/1xOg9kNRMfmUXoJAYNp7R93UHfPlVus-2VV-i-Rdx1Uc/edit#gid=0"
dat_erst <- gsheet2tbl(sheet_url)
#dat_erst <- read_csv(here("data", "Buerger_innenvorhersage 2021 - Prognose.csv"))


#' t-Test auf Basis von Mittelwert und Standardabweichung 
t_test_from_summary <- function(m1, m2, sd1, sd2, n1, n2, ...) {
  group1 <- scale(1:n1)*sd1 + m1
  group2 <- scale(1:n2)*sd2 + m2
  t.test(group1, group2, ...)
}


dat_erst_ttest <- dat_erst %>% 
  mutate(Stimmenanteil_Mean = ifelse(Stimmenanteil_Mean > 1000, 
                                     Stimmenanteil_Mean / 1000, 
                                     Stimmenanteil_Mean)) %>% 
  group_by(wkr) %>% 
  slice_max(order_by = Stimmenanteil_Mean, n = 2, with_ties = FALSE) %>% 
  mutate(rank = rank(-Stimmenanteil_Mean, ties.method = "first")) %>% 
  ungroup() %>% 
  select(wkr, rank, Stimmenanteil_Mean, Stimmenanteil_SD, obs) %>% 
  pivot_wider(id_cols = wkr, 
              names_from = "rank", 
              values_from = c("Stimmenanteil_Mean", "Stimmenanteil_SD", "obs")) %>% 
  mutate(t_test = pmap(list(m1 = Stimmenanteil_Mean_1, m2 = Stimmenanteil_Mean_2,
                      sd1 = Stimmenanteil_SD_1, sd2 = Stimmenanteil_SD_2,
                      n1 = obs_1, n2 = obs_2, alternative = "greater"), 
                      t_test_from_summary),
         t = map_dbl(t_test, "statistic"),
         p_value = map_dbl(t_test, "p.value"))

dat_erst_winneronly_dw <- 
  dat_erst %>%
  group_by(wkr) %>%
  dplyr::select(wkr, Wahlkreisname, party, kandidate_name, obs, Gewinner_share) %>%
  mutate(Gewinner_share = ifelse(Gewinner_share > 100, Gewinner_share / 1000, Gewinner_share),
         rank = rank(Gewinner_share, ties.method = "first"),
         name = to_character(wkr),
         Gewinner_share = round(Gewinner_share*100))  %>%
  filter(rank > 5) %>%
  mutate(party = as.character(party)) %>%
  unite(val, party, Gewinner_share, kandidate_name) %>%
  spread(rank,val) %>%
  separate("7",into = c("first-place-party", "first-place-votes", "winner"),"_") %>%
  separate("6",into = c("second-place-party", "second-place-votes", "second"),"_") %>%
  mutate(outcome = ifelse(`first-place-votes` == `second-place-votes`, 'Kopf-an-Kopf', `first-place-party`)) %>%
  relocate("outcome", "first-place-party", "first-place-votes", "winner", .before = "second-place-party") %>% 
  ungroup() %>% 
  # add t-test statistic
  inner_join(dat_erst_ttest, by = "wkr")

Kombinierte Datensätze

dat_winneronly_grid <- 
  dat_erst_winneronly_dw %>% 
  left_join(grid, by = c("Wahlkreisname" = "wk_full")) %>% 
  mutate(
    outcome_agg = ifelse(outcome %in% c("CDU", "CSU"), "CDU/CSU", outcome),
    diff = as.numeric(`first-place-votes`) - as.numeric(`second-place-votes`),
    outcome_agg = factor(outcome_agg, levels = c("CDU/CSU", "SPD", "Grüne", "Linke", "AfD", "Kopf-an-Kopf"))
  )

Visualisierungen

Setup

theme_set(theme_void(base_size = 16, base_family = "Editorial New")) #Editorial New, Noto Serif
theme_update(legend.margin = margin(0, 0, 0, 25),
             legend.text = element_text(margin = margin(5, 0, 5, 0)),
             plot.title = element_text(hjust = .5, face = "bold", 
                                       lineheight = 1.1, margin = margin(t = 10, b = 20)),
             plot.subtitle = element_text(hjust = .5, color = "grey40", size = 15,
                                          margin = margin(t = -8, b = 18)),
             plot.title.position = "plot",
             plot.caption = element_text(hjust = 0, color = "grey40", 
                                         lineheight = 1.3,
                                         size = 9, margin = margin(20, 0, 5, 0)),
             plot.caption.position = "plot",
             plot.margin = margin(10, 0, 10, 0))

# Party colors
party_colors <- c("CDU/CSU" = "grey9",
                  #"CSU" = "grey18",
                  "SPD" = "#ca0002", ## "#E3000F",  a bit darker now to make it work with CVD
                  "Grüne" = rgb(100, 161, 45, maxColorValue = 255),
                  #"FDP" = darken("#ffed00", 0.1),
                  "Linke" = "purple",
                  "AfD" = rgb(0, 158, 224, maxColorValue = 255))

caption_de <- "Grafik: Cédric Scherer & Ansgar Wolsing\nDaten: Kayser, Leininger, Murr & Stötzer (2021) Citizens’ Forecast for the 2021 German National Election (aleininger.eu/citizens_forecast2021)\nDie Karte basiert auf einer Befragung einer nicht-repräsentativen Stichprobe von Bürger*innen in allen 299 Wahlkreisen zu den Erfolgsaussichten des*der Kandidierenden*in."
title_de <- "Bürger*innenvorhersage der Direktmandatsgewinner*innen\nin den Wahlkreisen zur Bundestagswahl 2021"

caption_en <- "Graphic: Cédric Scherer & Ansgar Wolsing\nData: Kayser, Leininger, Murr & Stötzer (2021) Citizens’ Forecast for the 2021 German National Election (aleininger.eu/citizens_forecast2021)\nThe map is based on a survey of a non-representative sample of citizens in all 299 Bundestag constituencies on the candidates' chances of success."
title_en <- "Citizens’ Forecast of Direct Mandate Winners in\nthe Constituencies for the 2021 Federal Election"

parties_en <- c("CDU/CSU", "SPD", "The Greens", "The Left", "AFD", "Too close to call")

Tile Grid Map

g <- ggplot(dat_winneronly_grid, aes(col, row)) +
  geom_point(aes(color = outcome_agg), size = 12, shape = 15) +
  coord_fixed() +
  scale_x_continuous(limits = c(-.5, max(grid$col) + 2)) +
  scale_y_reverse(expand = c(.03, .03)) +
  scale_color_manual(values = c(party_colors, c("Kopf-an-Kopf" = "grey85")),
                     name = NULL) +
  guides(color = guide_legend(override.aes = list(size = 6))) +
  theme(legend.position = c(.87, .25))

## Deutsche Version
g + labs(title = title_de, caption = caption_de)
ggsave(here("plots", "citizen_forecast", "citizen_forecast_grid_map_de.pdf"), width = 10, height = 13, device = cairo_pdf)

## Englische Version
g + labs(title = title_en, caption = caption_en) +
  scale_color_manual(values = c(party_colors, c("Too close to call" = "grey85")),
                     name = NULL, labels = parties_en)
ggsave(here("plots", "citizen_forecast", "citizen_forecast_grid_map_en.pdf"), width = 10, height = 13, device = cairo_pdf)

Variante mit gedämpfteren Farben für die Füllung der Punkte

g <- 
  ggplot(dat_winneronly_grid, aes(col, row)) +
  geom_point(
    aes(fill = outcome_agg), 
    size = 11.5, shape = 22, stroke = 1.5, alpha = .5, color = "transparent"
  ) +
  geom_point(
    aes(color = outcome_agg), 
    size = 11.5, shape = 22, stroke = 1.5, fill = "transparent"
  ) +
  coord_fixed() +
  scale_x_continuous(limits = c(-.5, max(grid$col) + 2)) +
  scale_y_reverse(expand = c(.03, .03)) +
  scale_color_manual(values = c(party_colors, c("Kopf-an-Kopf" = "grey85")), name = NULL) +
  scale_fill_manual(values = c(party_colors, c("Kopf-an-Kopf" = "grey85")), name = NULL) +
  guides(color = guide_legend(override.aes = list(size = 6))) +
  theme(legend.position = c(.87, .25))

## Deutsche Version
g + labs(title = title_de, caption = caption_de)
ggsave(here("plots", "citizen_forecast", "citizen_forecast_grid_map_de_v2.pdf"), width = 10, height = 13, device = cairo_pdf)
 
## Englische Version
g + labs(title = title_en, caption = caption_en) +
  scale_color_manual(values = c(party_colors, c("Too close to call" = "grey85")),
                     name = NULL, labels = parties_en) +
  scale_fill_manual(values = c(party_colors, c("Too close to call" = "grey85")),
                    name = NULL, labels = parties_en)
ggsave(here("plots", "citizen_forecast", "citizen_forecast_grid_map_en_v2.pdf"), width = 10, height = 13, device = cairo_pdf)

Bubble Map

g <- ggplot(dat_winneronly_grid, aes(col, row)) +
  geom_point(aes(color = outcome_agg), size = 10) +
  coord_fixed() +
  scale_x_continuous(limits = c(-.5, max(grid$col) + 2)) +
  scale_y_reverse(expand = c(.03, .03)) +
  scale_color_manual(values = c(party_colors, c("Kopf-an-Kopf" = "grey85")),
                     name = NULL) +
  guides(color = guide_legend(override.aes = list(size = 6))) +
  theme(legend.position = c(.87, .25))

## Deutsche Version
g + labs(title = title_de, caption = caption_de)
ggsave(here("plots", "citizen_forecast", "citizen_forecast_bubble_map_de.pdf"), width = 10, height = 13, device = cairo_pdf)

## Englische Version
g + labs(title = title_en, caption = caption_en) +
  scale_color_manual(values = c(party_colors, c("Too close to call" = "grey85")),
                     name = NULL, labels = parties_en)
ggsave(here("plots", "citizen_forecast", "citizen_forecast_bubble_map_en.pdf"), width = 10, height = 13, device = cairo_pdf)

Variante mit gedämpfteren Farben für die Füllung der Punkte

g <- 
  ggplot(dat_winneronly_grid, aes(col, row)) +
  geom_point(
    aes(fill = outcome_agg), 
    size = 10, shape = 21, stroke = 2, alpha = .5, color = "transparent"
  ) +
  geom_point(
    aes(color = outcome_agg), 
    size = 10, shape = 21, stroke = 2, fill = "transparent"
  ) +
  coord_fixed() +
  scale_x_continuous(limits = c(-.5, max(grid$col) + 2)) +
  scale_y_reverse(expand = c(.03, .03)) +
  scale_color_manual(values = c(party_colors, c("Kopf-an-Kopf" = "grey85")), name = NULL) +
  scale_fill_manual(values = c(party_colors, c("Kopf-an-Kopf" = "grey85")), name = NULL) +
  guides(color = guide_legend(override.aes = list(size = 6))) +
  theme(legend.position = c(.87, .25))

## Deutsche Version
g + labs(title = title_de, caption = caption_de)
ggsave(here("plots", "citizen_forecast", "citizen_forecast_bubble_map_de_v2.pdf"), width = 10, height = 13, device = cairo_pdf)
 
## Englische Version
g + labs(title = title_en, caption = caption_en) +
  scale_color_manual(values = c(party_colors, c("Too close to call" = "grey85")),
                     name = NULL, labels = parties_en) +
  scale_fill_manual(values = c(party_colors, c("Too close to call" = "grey85")),
                    name = NULL, labels = parties_en)
ggsave(here("plots", "citizen_forecast", "citizen_forecast_bubble_map_en_v2.pdf"), width = 10, height = 13, device = cairo_pdf)

Grid Map inkl. Vorsprung als Farbintensität

Vorsprung in Prozentpunkten

g <- 
  ggplot(dat_winneronly_grid, aes(col, row)) +
  geom_point(
    aes(fill = outcome_agg, alpha = diff), 
    size = 11.5, shape = 22, stroke = 1.5, color = "transparent"
  ) +
  geom_point(
    aes(color = outcome_agg), 
    size = 11.5, shape = 22, stroke = 1.5, fill = "transparent"
  ) +
  coord_fixed() +
  scale_x_continuous(limits = c(-.5, max(grid$col) + 2)) +
  scale_y_reverse(expand = c(.03, .03)) +
  scale_color_manual(values = c(party_colors, c("Kopf-an-Kopf" = "grey85")), name = NULL) +
  scale_fill_manual(values = c(party_colors, c("Kopf-an-Kopf" = "transparent")), name = NULL) +
  scale_alpha(range = c(0, .86), guide = "none") +
  guides(fill = guide_legend(override.aes = list(size = 6, alpha = .9))) +
  theme(legend.position = c(.87, .25))

## Deutsche Version
g + labs(title = title_de, caption = caption_de,
         subtitle = "Je intensiver die Färbung, desto größer ist der vorhergesagte Vorsprung.")
ggsave(here("plots", "citizen_forecast", "citizen_forecast_grid_map_diff_de.pdf"), width = 10, height = 13, device = cairo_pdf)

## Englische Version
g + labs(title = title_en, caption = caption_en,
         subtitle = "The more intense the coloring of the dots, the greater the predicted lead.") +
  scale_color_manual(values = c(party_colors, c("Too close to call" = "grey85")),
                     name = NULL, labels = parties_en) +
  scale_fill_manual(values = c(party_colors, c("Too close to call" = "grey85")),
                    name = NULL, labels = parties_en)
ggsave(here("plots", "citizen_forecast", "citizen_forecast_grid_map_diff_en.pdf"), width = 10, height = 13, device = cairo_pdf)

Bubble Map inkl. Vorsprung als Farbintensität

Vorsprung in Prozentpunkten

g <- 
  ggplot(dat_winneronly_grid, aes(col, row)) +
  geom_point(
    aes(fill = outcome_agg, alpha = diff), 
    size = 9, shape = 21, stroke = 2, color = "transparent"
  ) +
  geom_point(
    aes(color = outcome_agg), 
    size = 9, shape = 21, stroke = 2, fill = "transparent"
  ) +
  coord_fixed() +
  scale_x_continuous(limits = c(-.5, max(grid$col) + 2)) +
  scale_y_reverse(expand = c(.03, .03)) +
  scale_color_manual(values = c(party_colors, c("Kopf-an-Kopf" = "grey85")), name = NULL) +
  scale_fill_manual(values = c(party_colors, c("Kopf-an-Kopf" = "transparent")), name = NULL) +
  scale_alpha(range = c(0, .86), guide = "none") +
  guides(fill = guide_legend(override.aes = list(size = 6, alpha = .9))) +
  theme(legend.position = c(.87, .25))

## Deutsche Version
g + labs(title = title_de, caption = caption_de,
         subtitle = "Je intensiver die Färbung, desto größer ist der vorhergesagte Vorsprung.")
ggsave(here("plots", "citizen_forecast", "citizen_forecast_bubble_map_diff_de.pdf"), width = 10, height = 13, device = cairo_pdf)

## Englische Version
g + labs(title = title_en, caption = caption_en,
         subtitle = "The more intense the coloring of the dots, the greater the predicted lead.") +
  scale_color_manual(values = c(party_colors, c("Too close to call" = "grey85")),
                     name = NULL, labels = parties_en) +
  scale_fill_manual(values = c(party_colors, c("Too close to call" = "grey85")),
                    name = NULL, labels = parties_en)
ggsave(here("plots", "citizen_forecast", "citizen_forecast_bubble_map_diff_en.pdf"), width = 10, height = 13, device = cairo_pdf)

Vorsprung als t-Statistik

g <- 
  ggplot(dat_winneronly_grid, aes(col, row)) +
  geom_point(
    aes(fill = outcome_agg, 
        # alpha = diff
        alpha = t # Ergebnis t-Test (oder p-value stattdessen?)
        ), 
    size = 9, shape = 21, stroke = 2, color = "transparent"
  ) +
  geom_point(
    aes(color = outcome_agg), 
    size = 9, shape = 21, stroke = 2, fill = "transparent"
  ) +
  coord_fixed() +
  scale_x_continuous(limits = c(-.5, max(grid$col) + 2)) +
  scale_y_reverse(expand = c(.03, .03)) +
  scale_color_manual(values = c(party_colors, c("Kopf-an-Kopf" = "grey85")), name = NULL) +
  scale_fill_manual(values = c(party_colors, c("Kopf-an-Kopf" = "transparent")), name = NULL) +
  scale_alpha(range = c(0, .86), guide = "none") +
  guides(fill = guide_legend(override.aes = list(size = 6, alpha = .9))) +
  theme(legend.position = c(.87, .25))

## Deutsche Version
g + labs(title = title_de, caption = glue("{caption_de}\nDie Vorhersage der Mandatsgewinner basiert auf einem t-Test auf Basis von Mittelwert und Standardabweichung."),
         subtitle = "Je intensiver die Färbung, desto größer ist der vorhergesagte Vorsprung.")
ggsave(here("plots", "citizen_forecast", "citizen_forecast_bubble_map_t_test_de.pdf"), width = 10, height = 13, device = cairo_pdf)

## Englische Version
g + labs(title = title_en, caption = glue("{caption_en}\nThe prediction of mandate winners is based on a t-test based on mean and standard deviation."),
         subtitle = "The more intense the coloring, the greater the predicted lead.") +
  scale_color_manual(values = c(party_colors, c("Too close to call" = "grey85")),
                     name = NULL, labels = parties_en) +
  scale_fill_manual(values = c(party_colors, c("Too close to call" = "grey85")),
                    name = NULL, labels = parties_en)
ggsave(here("plots", "citizen_forecast", "citizen_forecast_bubble_map_t_test_en.pdf"), width = 10, height = 13, device = cairo_pdf)

Bubble Map inkl. Grenzen der Bundesländer (trial)

Leider nicht so schön und sinnvoll wie erhofft.

ggplot(dat_winneronly_grid, aes(col, row)) +
  ggforce::geom_mark_hull(
    aes(group = bundesland_de), 
    color = "white",
    expand = unit(0, "mm")
  ) +
  geom_point(aes(color = outcome_agg), size = 7) +
  coord_fixed() +
  scale_x_continuous(limits = c(-.5, max(grid$col) + 2)) +
  scale_y_reverse(expand = c(.03, .03)) +
  scale_color_manual(values = c(party_colors, c("Kopf-an-Kopf" = "grey85")),
                     name = NULL) +
  guides(color = guide_legend(override.aes = list(size = 6))) +
  theme(legend.position = c(.87, .25),
        plot.background = element_rect(color = "grey67", fill = "grey67")) +
  labs(title = title_de, caption = caption_de)

ggsave(here("plots", "citizen_forecast", "citizen_forecast_bubble_map_states.pdf"), width = 10, height = 13, device = cairo_pdf)

Bubble Map mit verschiedenen Punktgrößen für Bundesländer (trial)

Weder effektiv noch schön.

# Größenkategorien für Bundesländer
bland_group_mapping <- c(
  "Schleswig-Holstein" = "A",
  "Mecklenburg-Vorpommern" = "B",
  "Hamburg" = "D",
  "Niedersachsen" = "C",
  "Bremen" = "E",
  "Brandenburg" = "A",
  "Sachsen-Anhalt" = "D",
  "Berlin" = "A",
  "Nordrhein-Westfalen" = "D",
  "Sachsen" = "A",
  "Hessen" = "E",
  "Thüringen" = "B",
  "Rheinland-Pfalz" = "A",
  "Bayern" = "D",
  "Baden-Württemberg" = "B",
  "Saarland" = "A"
)

dat_winneronly_grid %>% 
  mutate(mark_group = bland_group_mapping[bundesland_de],
         mark_shape = case_when(
           mark_group == "A" ~ 21,
           mark_group == "B" ~ 22,
           mark_group == "C" ~ 23,
           mark_group == "D" ~ 24,
           mark_group == "E" ~ 25,
         )) %>% 
  ggplot(aes(col, row)) +
  geom_point(
    aes(fill = outcome_agg, alpha = diff, size = mark_group), 
    # size = 9, 
    shape = 21, 
    stroke = 2, color = "transparent"
  ) +
  geom_point(
    aes(color = outcome_agg, size = mark_group), 
    # size = 9, 
    shape = 21, 
    stroke = 2, fill = "transparent"
  ) +
  coord_fixed() +
  scale_x_continuous(limits = c(-.5, max(grid$col) + 2)) +
  scale_y_reverse(expand = c(.03, .03)) +
  scale_color_manual(values = c(party_colors, c("Kopf-an-Kopf" = "grey85")), name = NULL) +
  scale_fill_manual(values = c(party_colors, c("Kopf-an-Kopf" = "transparent")), name = NULL) +
  scale_alpha(range = c(0, .86), guide = "none") +
  scale_size_discrete(range = c(7, 11)) +
  # scale_shape_identity() +
  guides(fill = guide_legend(override.aes = list(size = 6, alpha = .9)),
         size = "none") +
  theme(legend.position = c(.87, .25)) +
  labs(title = title_de, caption = caption_de,
       subtitle = "Je intensiver die Färbung, desto größer ist der vorhergesagte Vorsprung.")

ggsave(here("plots", "citizen_forecast", "citizen_forecast_bubble_map_diff_bland_mark.pdf"), width = 10, height = 13, device = cairo_pdf)

Bubble Map inkl. Vorsprung als Farbintensität - mit Städten zur Orientierung

constituencies_to_highlight <- c(
  18, # Hamburg-Mitte
  75, # Berlin-Mitte
  93, # Köln I
  220 # München-West/Mitte
)

df_constituencies_highlight <- dat_winneronly_grid %>% 
  filter(wkr %in% constituencies_to_highlight) %>% 
  mutate(name_short = str_extract(Wahlkreisname, "[a-zA-ZäöüÄÖÜ]+")) %>% 
  select(name_short, name, col, row)

Städtenamen als Overlay

ggplot(dat_winneronly_grid, aes(col, row)) +
  geom_point(
    aes(fill = outcome_agg, alpha = diff), 
    size = 9, shape = 21, stroke = 2, color = "transparent"
  ) +
  geom_point(
    aes(color = outcome_agg), 
    size = 9, shape = 21, stroke = 2, fill = "transparent"
  ) +
  geom_label(data = df_constituencies_highlight,
             aes(label = name_short),
             col = "grey99",
             fill = "grey10", alpha = 0.4, family = "Roboto",
             label.size = 0, 
             fontface = "bold", size = 6,
             hjust = 0.5) +
  coord_fixed() +
  scale_x_continuous(limits = c(-.5, max(grid$col) + 2)) +
  scale_y_reverse(expand = c(.03, .03)) +
  scale_color_manual(values = c(party_colors, c("Kopf-an-Kopf" = "grey85")), name = NULL) +
  scale_fill_manual(values = c(party_colors, c("Kopf-an-Kopf" = "transparent")), name = NULL) +
  scale_alpha(range = c(0, .86), guide = "none") +
  guides(fill = guide_legend(override.aes = list(size = 6, alpha = .9))) +
  theme(legend.position = c(.87, .25)) +
  labs(title = title_de, caption = caption_de,
       subtitle = "Je intensiver die Färbung, desto größer ist der vorhergesagte Vorsprung.")

ggsave(here("plots", "citizen_forecast", "citizen_forecast_bubble_map_diff_location_highlights.pdf"), width = 10, height = 13, device = cairo_pdf)

Städtenamen als Labels

labels <- dat_winneronly_grid %>% 
  filter(str_detect(wk, "München|Köln") | bundesland_de %in% c("Berlin", "Hamburg")) %>% 
  filter(wk != "München-Land") %>% 
  mutate(label = case_when(
    str_detect(wk, "München") ~ "München",
    str_detect(wk, "Köln") ~ "Köln",
    TRUE ~ bundesland_de
  ))


ggplot(dat_winneronly_grid, aes(col, row)) +
  geom_tile(
    data = labels,
    fill = "grey60", color = "grey60"
  ) +
  geom_point(
    fill = "white", size = 9, shape = 21, stroke = 2, color = "transparent"
  ) +
  geom_point(
    aes(fill = outcome_agg, alpha = diff), 
    size = 9, shape = 21, stroke = 2, color = "transparent"
  ) +
  geom_point(
    aes(color = outcome_agg), 
    size = 9, shape = 21, stroke = 2, fill = "transparent"
  ) +
  # ggforce::geom_mark_hull(
  #   data = labels,
  #   aes(group = label),
  #   concavity = 0
  # ) +
  coord_fixed() +
  scale_x_continuous(limits = c(-.5, max(grid$col) + 2)) +
  scale_y_reverse(expand = c(.03, .03)) +
  scale_color_manual(values = c(party_colors, c("Kopf-an-Kopf" = "grey85")), name = NULL) +
  scale_fill_manual(values = c(party_colors, c("Kopf-an-Kopf" = "transparent")), name = NULL) +
  scale_alpha(range = c(0, .86), guide = "none") +
  guides(fill = guide_legend(override.aes = list(size = 6, alpha = .9))) +
  theme(legend.position = c(.87, .25)) +
  labs(title = title_de, caption = caption_de,
       subtitle = "Je intensiver die Färbung, desto größer ist der vorhergesagte Vorsprung.")

ggsave(here("plots", "citizen_forecast", "citizen_forecast_bubble_map_diff_location_highlights_ggforce.pdf"), width = 10, height = 13, device = cairo_pdf)

Interaktive Version via {ggiraph}

library(ggiraph)

g_interactive <- dat_winneronly_grid %>% 
  mutate(label = str_wrap(glue("{Wahlkreisname} ({bundesland_de})<br><br>Vorsprung:<br>{outcome} {diff}%"), 50)) %>% 
  ggplot(aes(col, row)) +
  geom_point_interactive(
    aes(fill = outcome_agg, alpha = diff, tooltip = label, data_id = label), 
    size = 9, shape = 21, stroke = 2, color = "transparent"
  ) +
  geom_point(
    aes(color = outcome_agg), 
    size = 9, shape = 21, stroke = 2, fill = "transparent"
  ) +
  coord_fixed() +
  scale_x_continuous(limits = c(-.5, max(grid$col) + 2)) +
  scale_y_reverse(expand = c(.03, .03)) +
  scale_color_manual(values = c(party_colors, c("Kopf-an-Kopf" = "grey85")), name = NULL) +
  scale_fill_manual(values = c(party_colors, c("Kopf-an-Kopf" = "transparent")), name = NULL) +
  scale_alpha(range = c(0, .86), guide = "none") +
  guides(color = guide_legend(override.aes = list(size = 6))) +
  labs(title = title_de, caption = caption_de)

tooltip_css <- "background-color:#515151;color:white;font-family:Roboto;padding:10px;border-radius:5px;"

girafe(ggobj = g_interactive, 
       width_svg = 12, height_svg = 12, 
       options = list(
         opts_sizing(rescale = FALSE),
         opts_tooltip(offx = 50, css = tooltip_css)
       ))
#ggsave(here("plots", "citizen_forecast", "citizen_forecast_bubble_map_states.pdf"), width = 10, height = 13, device = cairo_pdf)

Hexagon Tiles

## READ GEOMETRY ==============================================
#' https://pitchinteractiveinc.github.io/tilegrams/
#' Download geometry "Germany - Constituencies" as TopoJSON
#' and place it in the data directory
filepath_topo <- here("data", "tiles.topo.json")
wk_topo <- geojsonio::topojson_read(filepath_topo)
wk_topo <- wk_topo %>% mutate(id = as.numeric(id))

# Merge shapes of constituencies into state-level shapes 
bland_shape <- wk_topo %>% 
  inner_join(dat_winneronly_grid, by = c("id" = "wkr")) %>% 
  group_by(bundesland_de) %>% 
  summarize(geometry = st_union(geometry))

df_constituencies_highlight_hex <- wk_topo %>% 
  filter(id %in% constituencies_to_highlight) %>% 
  mutate(geometry = st_make_valid(geometry) %>% 
           st_centroid(),
         lon = map(geometry, 1),
         lat = map(geometry, 2),
         name_short = str_extract(name, "[a-zA-ZäöüÄÖÜ]+"))
g <- dat_winneronly_grid %>% 
  inner_join(wk_topo, by = c("wkr" = "id")) %>% 
  ggplot(aes(geometry = geometry)) +
  geom_sf(aes(fill = outcome_agg, col = outcome_agg, alpha = diff),
          size = 0.1, # col = "grey80"
          ) +
  geom_sf_text(aes(label = id),
               size = 2.5, family = "Roboto Mono") +
  geom_sf(data = bland_shape,
          aes(geometry = geometry, 
              group = bundesland_de),
          fill = NA, col = "grey96",
          size = 2, show.legend = FALSE) +
  geom_sf(aes(col = outcome_agg),
          size = 0.1, fill = "transparent"
          ) +
  # geom_sf_label(data = df_constituencies_highlight_hex,
  #            aes(lon, lat, label = name_short),
  #            col = "grey99",
  #            fill = "grey10", alpha = 0.4, family = "Roboto",
  #            label.size = 0,
  #            fontface = "bold", size = 6,
  #            hjust = 0.5) +
  #scale_x_continuous(limits = c(NA, )) +
  scale_y_continuous(expand = c(.01, .01)) +
  scale_color_manual(values = c(party_colors, c("Kopf-an-Kopf" = "grey85")), name = NULL) +
  scale_fill_manual(values = c(party_colors, c("Kopf-an-Kopf" = "transparent")), name = NULL) +
  scale_alpha(range = c(0, .86), guide = "none") +
  guides(fill = guide_legend(override.aes = list(size = 0.25, alpha = .5))) +
  theme(legend.position = c(.08, .15),
        legend.key.size = unit(5, "mm"))

## Deutsche Version
g + labs(title = title_de, 
         subtitle = "Je intensiver die Färbung, desto größer ist der vorhergesagte Vorsprung.",
         caption = glue("{caption_de}\nTilegram-Geometrie: pitchinteractiveinc.github.io"))
ggsave(here("plots", "citizen_forecast", "citizen_forecast_hexagon_map_diff_de.pdf"), width = 10, height = 13, device = cairo_pdf)

## Englische Version
g + labs(title = title_en, 
         subtitle = "The more intense the coloring of the dots, the greater the predicted lead.",
         caption = glue("{caption_en}\nTilegram-Geometrie: pitchinteractiveinc.github.io")) +
  scale_color_manual(values = c(party_colors, c("Kopf-an-Kopf" = "grey85")),
                     name = NULL, labels = parties_en) +
  scale_fill_manual(values = c(party_colors, c("Kopf-an-Kopf" = "grey85")),
                    name = NULL, labels = parties_en)
ggsave(here("plots", "citizen_forecast", "citizen_forecast_hexagon_map_diff_en.pdf"), width = 10, height = 13, device = cairo_pdf)
g <- dat_winneronly_grid %>% 
  inner_join(wk_topo, by = c("wkr" = "id")) %>% 
  ggplot(aes(geometry = geometry)) +
  geom_sf(aes(fill = outcome_agg, col = outcome_agg, alpha = t),
          size = 0.1, # col = "grey80"
          ) +
  geom_sf_text(aes(label = id),
               size = 2.5, family = "Roboto Mono") +
  geom_sf(data = bland_shape,
          aes(geometry = geometry, 
              group = bundesland_de),
          fill = NA, col = "grey96",
          size = 2, show.legend = FALSE) +
  geom_sf(aes(col = outcome_agg),
          size = 0.1, fill = "transparent"
          ) +
  # geom_sf_label(data = df_constituencies_highlight_hex,
  #            aes(lon, lat, label = name_short),
  #            col = "grey99",
  #            fill = "grey10", alpha = 0.4, family = "Roboto",
  #            label.size = 0,
  #            fontface = "bold", size = 6,
  #            hjust = 0.5) +
  #scale_x_continuous(limits = c(NA, )) +
  scale_y_continuous(expand = c(.01, .01)) +
  scale_color_manual(values = c(party_colors, c("Kopf-an-Kopf" = "grey85")), name = NULL) +
  scale_fill_manual(values = c(party_colors, c("Kopf-an-Kopf" = "transparent")), name = NULL) +
  scale_alpha(range = c(0, .86), guide = "none") +
  guides(fill = guide_legend(override.aes = list(size = 0.25, alpha = .5))) +
  theme(legend.position = c(.08, .15),
        legend.key.size = unit(5, "mm"))

## Deutsche Version
g + labs(title = title_de, 
         subtitle = "Je intensiver die Färbung, desto größer ist der vorhergesagte Vorsprung.",
         caption = glue("{caption_de}\nTilegram-Geometrie: pitchinteractiveinc.github.io"))
ggsave(here("plots", "citizen_forecast", "citizen_forecast_hexagon_map_t_test_de.pdf"), width = 10, height = 13, device = cairo_pdf)

## Englische Version
g + labs(title = title_en, 
         subtitle = "The more intense the coloring of the dots, the greater the predicted lead.",
         caption = glue("{caption_en}\nTilegram-Geometrie: pitchinteractiveinc.github.io")) +
  scale_color_manual(values = c(party_colors, c("Kopf-an-Kopf" = "grey85")),
                     name = NULL, labels = parties_en) +
  scale_fill_manual(values = c(party_colors, c("Kopf-an-Kopf" = "grey85")),
                    name = NULL, labels = parties_en)
ggsave(here("plots", "citizen_forecast", "citizen_forecast_hexagon_map_t_test_en.pdf"), width = 10, height = 13, device = cairo_pdf)
pdfs <- list.files(here(), pattern = "*.pdf", recursive = TRUE)
for(pdf in pdfs) {
  pdf_convert(pdf = glue("{here()}/{pdf}"), 
              filenames = glue("{here()}/{str_remove(pdf, '.pdf')}.png"),
              format = "png", dpi = 500)
}
Converting page 1 to C:/Users/DataVizard/Google Drive/Work/DataViz/Personal/2021_Bundestagswahl/btw_tilemap/plots/citizen_forecast/citizen_forecast_bubble_map_de.png... done!
Converting page 1 to C:/Users/DataVizard/Google Drive/Work/DataViz/Personal/2021_Bundestagswahl/btw_tilemap/plots/citizen_forecast/citizen_forecast_bubble_map_de_v2.png... done!
Converting page 1 to C:/Users/DataVizard/Google Drive/Work/DataViz/Personal/2021_Bundestagswahl/btw_tilemap/plots/citizen_forecast/citizen_forecast_bubble_map_diff_de.png... done!
Converting page 1 to C:/Users/DataVizard/Google Drive/Work/DataViz/Personal/2021_Bundestagswahl/btw_tilemap/plots/citizen_forecast/citizen_forecast_bubble_map_diff_en.png... done!
Converting page 1 to C:/Users/DataVizard/Google Drive/Work/DataViz/Personal/2021_Bundestagswahl/btw_tilemap/plots/citizen_forecast/citizen_forecast_bubble_map_en.png... done!
Converting page 1 to C:/Users/DataVizard/Google Drive/Work/DataViz/Personal/2021_Bundestagswahl/btw_tilemap/plots/citizen_forecast/citizen_forecast_bubble_map_en_v2.png... done!
Converting page 1 to C:/Users/DataVizard/Google Drive/Work/DataViz/Personal/2021_Bundestagswahl/btw_tilemap/plots/citizen_forecast/citizen_forecast_bubble_map_t_test_de.png... done!
Converting page 1 to C:/Users/DataVizard/Google Drive/Work/DataViz/Personal/2021_Bundestagswahl/btw_tilemap/plots/citizen_forecast/citizen_forecast_bubble_map_t_test_en.png... done!
Converting page 1 to C:/Users/DataVizard/Google Drive/Work/DataViz/Personal/2021_Bundestagswahl/btw_tilemap/plots/citizen_forecast/citizen_forecast_grid_map_de.png... done!
Converting page 1 to C:/Users/DataVizard/Google Drive/Work/DataViz/Personal/2021_Bundestagswahl/btw_tilemap/plots/citizen_forecast/citizen_forecast_grid_map_de_v2.png... done!
Converting page 1 to C:/Users/DataVizard/Google Drive/Work/DataViz/Personal/2021_Bundestagswahl/btw_tilemap/plots/citizen_forecast/citizen_forecast_grid_map_diff_de.png... done!
Converting page 1 to C:/Users/DataVizard/Google Drive/Work/DataViz/Personal/2021_Bundestagswahl/btw_tilemap/plots/citizen_forecast/citizen_forecast_grid_map_diff_en.png... done!
Converting page 1 to C:/Users/DataVizard/Google Drive/Work/DataViz/Personal/2021_Bundestagswahl/btw_tilemap/plots/citizen_forecast/citizen_forecast_grid_map_en.png... done!
Converting page 1 to C:/Users/DataVizard/Google Drive/Work/DataViz/Personal/2021_Bundestagswahl/btw_tilemap/plots/citizen_forecast/citizen_forecast_grid_map_en_v2.png... done!
Converting page 1 to C:/Users/DataVizard/Google Drive/Work/DataViz/Personal/2021_Bundestagswahl/btw_tilemap/plots/citizen_forecast/citizen_forecast_hexagon_map_diff_de.png... done!
Converting page 1 to C:/Users/DataVizard/Google Drive/Work/DataViz/Personal/2021_Bundestagswahl/btw_tilemap/plots/citizen_forecast/citizen_forecast_hexagon_map_diff_en.png... done!
Converting page 1 to C:/Users/DataVizard/Google Drive/Work/DataViz/Personal/2021_Bundestagswahl/btw_tilemap/plots/citizen_forecast/citizen_forecast_hexagon_map_t_test_de.png... done!
Converting page 1 to C:/Users/DataVizard/Google Drive/Work/DataViz/Personal/2021_Bundestagswahl/btw_tilemap/plots/citizen_forecast/citizen_forecast_hexagon_map_t_test_en.png... done!

Session Info
[1] "2021-09-27 14:44:16 CEST"
R version 4.1.0 (2021-05-18)
Platform: x86_64-w64-mingw32/x64 (64-bit)
Running under: Windows 10 x64 (build 19043)

Matrix products: default

locale:
[1] LC_COLLATE=German_Germany.1252  LC_CTYPE=German_Germany.1252   
[3] LC_MONETARY=German_Germany.1252 LC_NUMERIC=C                   
[5] LC_TIME=German_Germany.1252    
system code page: 65001

attached base packages:
[1] stats     graphics  grDevices utils     datasets  methods  
[7] base     

other attached packages:
 [1] ggiraph_0.7.10   pdftools_3.0.1   sf_1.0-2        
 [4] labelled_2.8.0   gsheet_0.4.5     colorspace_2.0-2
 [7] glue_1.4.2       here_1.0.1       forcats_0.5.1   
[10] stringr_1.4.0    dplyr_1.0.7      purrr_0.3.4     
[13] readr_2.0.1      tidyr_1.1.3      tibble_3.1.4    
[16] ggplot2_3.3.5    tidyverse_1.3.1 

loaded via a namespace (and not attached):
 [1] ellipsis_0.3.2     class_7.3-19       rprojroot_2.0.2   
 [4] fs_1.5.0           rstudioapi_0.13    httpcode_0.3.0    
 [7] proxy_0.4-26       farver_2.1.0       bit64_4.0.5       
[10] fansi_0.5.0        lubridate_1.7.10   xml2_1.3.2        
[13] downlit_0.2.1      knitr_1.34         jsonlite_1.7.2    
[16] broom_0.7.9        dbplyr_2.1.1       rgeos_0.5-8       
[19] compiler_4.1.0     httr_1.4.2         backports_1.2.1   
[22] assertthat_0.2.1   fastmap_1.1.0      lazyeval_0.2.2    
[25] cli_3.0.0          htmltools_0.5.2    tools_4.1.0       
[28] gtable_0.3.0       geojson_0.3.4      V8_3.4.2          
[31] Rcpp_1.0.7         cellranger_1.1.0   jquerylib_0.1.4   
[34] vctrs_0.3.8        crul_1.1.0         xfun_0.26         
[37] rvest_1.0.1        lifecycle_1.0.1    pacman_0.5.1      
[40] jqr_1.2.1          scales_1.1.1       vroom_1.5.5       
[43] ragg_1.1.3         hms_1.1.1          parallel_4.1.0    
[46] yaml_2.2.1         curl_4.3.2         sass_0.4.0        
[49] distill_1.2        stringi_1.7.4      highr_0.9         
[52] maptools_1.1-2     e1071_1.7-9        rlang_0.4.11      
[55] pkgconfig_2.0.3    systemfonts_1.0.2  evaluate_0.14     
[58] lattice_0.20-44    htmlwidgets_1.5.4  labeling_0.4.2    
[61] bit_4.0.4          tidyselect_1.1.1   magrittr_2.0.1    
[64] geojsonsf_2.0.1    R6_2.5.1           geojsonio_0.9.4   
[67] generics_0.1.0     DBI_1.1.1          foreign_0.8-81    
[70] pillar_1.6.3       haven_2.4.3        withr_2.4.2       
[73] units_0.7-2        sp_1.4-5           modelr_0.1.8      
[76] crayon_1.4.1       uuid_0.1-4         KernSmooth_2.23-20
[79] utf8_1.2.2         tzdb_0.1.2         rmarkdown_2.11    
[82] grid_4.1.0         readxl_1.3.1       qpdf_1.1          
[85] reprex_2.0.1       digest_0.6.28      classInt_0.4-3    
[88] textshaping_0.3.5  munsell_0.5.0      bslib_0.3.0       
[91] askpass_1.1